perm filename TRACK.SAI[KI,ALS]1 blob sn#093374 filedate 1974-03-25 generic text, type T, neo UTF8
00010	ENTRY TRACK;
00020	BEGIN
00030	DEFINE ⊂="COMMENT",CR="'15",LF="'12", CRLF="CR&LF",TB="'11";
00040	DEFINE ⊃="⊂"; ⊂  Used to introduce debugging outstr's;
00050	INTEGER I,J,K,L,M,VSTART,VEND,POINTR,OLDBUF,EOF,SMIN,SMAX,PSTART,PEND;
00060	INTEGER ALPHA,SAMPLE,ISAVE,ZEROS,GAMMA;
00070	EXTERNAL INTEGER CHAN3;
00080	BOOLEAN ER;
00090	REAL VAL,X,Y,Z;
00100	INTEGER ARRAY BUF1,BUF2,HOLD[0:512];
00110	INTERNAL REAL ARRAY A,B,WINDOW[0:512];
00120	EXTERNAL INTEGER F1,F2,F3,A1,A2,A3;
00130	INTERNAL REAL ARRAY C[0:512];
00140	EXTERNAL INTEGER ARRAY SPOOR[0:5,0:20];
00150	EXTERNAL INTEGER SPX;
00160	INTERNAL INTEGER F1AS,F1S,F2S,F3S,F4S,F5S;
00170	INTERNAL REAL CF1S;
00180	
00190	
00200	⊂ DEFINE \=" ";  DEFINE \="SAFE"; ⊂ Alternarte definitions;
00210	 REQUIRE "LPC[X,ALS]" LOAD_MODULE;
00220	REQUIRE "INDATK[KI,ALS]" LOAD_MODULE;
00230	EXTERNAL INTEGER ARRAY INNAME,INDATA[0:32];
00240	EXTERNAL PROCEDURE DEFINES;
00250	EXTERNAL PROCEDURE PREPARE;
00260	EXTERNAL INTEGER INFLAG,NX;
00270	FORTRAN REAL PROCEDURE SQRT(REAL X);
00280	FORTRAN REAL PROCEDURE ALOG10(REAL X);
00290	FORTRAN REAL PROCEDURE COS(REAL X);
00300	FORTRAN REAL PROCEDURE SIN(REAL X);
00310	INTEGER ZEROC,ZEROF,DX;
00320	 EXTERNAL FORTRAN PROCEDURE LPC(REFERENCE REAL AIFFY,SPT;
00330	    REFERENCE INTEGER NPTS,M,NSP);
00340	REQUIRE "FFT8X[X,ALS]" LOAD_MODULE;
00350	EXTERNAL FORTRAN PROCEDURE FRXFM
00360	         (REFERENCE INTEGER M;REFERENCE REAL X,Y);
00370	
00380	INTERNAL PROCEDURE FORM(INTEGER LPCOPT);
00390	BEGIN "FORM"
00400	REAL ERRN,ERR;
00410	INTEGER I,J,LP,JJP,N,M;
00420	
00430	IF LPCOPT=1 THEN BEGIN "FFT"
00440	 M←9; N←2↑M; DEFINE PI="3.141592653";
00450	⊃ OUTSTR("Entering FORM"&CRLF);
00460	
00470	  N←PEND-PSTART; J←0;
00480	⊃ OUTSTR(CVS(PSTART)&TB&CVS(PEND)&CRLF);
00490	    FOR I←0 STEP 1 UNTIL PSTART DO WINDOW[I]←0;
00500	    FOR I←PSTART STEP 1 UNTIL PEND DO BEGIN
00510	      WINDOW[I]←(1-COS((2*PI*J)/N))/2;
00520	      J←J+1; END;
00530	    FOR I←PEND+1 STEP 1 UNTIL 512 DO WINDOW[I]←0;
00540	FOR I←0 STEP 1 UNTIL 512 DO BEGIN
00550	  A[I]←HOLD[I]*WINDOW[I]; B[I]←0;
00560	  END;
00570	
00580	
00590	FRXFM(M,A[0],B[0]);
00600	⊃ OUTSTR("FFT COMPLETE"&CRLF);
00610	FOR I←0 STEP 1 UNTIL 256 DO BEGIN
00620	  X←(A[I]↑2)+(B[I]↑2)+1.*(10↑-37);
00630	  C[I]←10.*ALOG10(X);
00640	  END;
00650	
00660	END "FFT" ELSE BEGIN "LPC"	
00670	
00680	⊃ OUTSTR("Entering LPC"&CRLF);
00690	  I←PSTART; N←PEND-PSTART;
00700	  LPC(HOLD[I],C[0],N,M,256);
00710	  END "LPC";
00720	
00730	END "FORM";
00740	
00750	
00760	PROCEDURE REPLACE;
00770	BEGIN
00780	
00790	    FOR I←0 STEP 1 UNTIL 511 DO BUF1[I]←0;
00800	⊃ OUTSTR("Ready to reload BUF1"&CRLF);
00810	    POINTR←POINT(12,BUF1[0],-1);
00820	    ARRYIN(CHAN3,BUF1[0],512);
00830	  OLDBUF←OLDBUF+1; I←0; SAMPLE←SAMPLE+1536;
00840	
00850	⊃ OUTSTR("Sample="&CVS(SAMPLE)&CRLF);
00860	END;
00870	
00880	INTEGER ARRAY PEAK,NPEAK,PLACE,NPLACE,PEAKX,NPEAKX[0:3];
00890	
00895	INTEGER XING;
00900	INTERNAL PROCEDURE TRACK;
00910	BEGIN
00920	INTEGER MAX,MAXX,MIN,MINX,STATE,MAXOLD,MINOLD,OLDXX,OLDNX,PERIOD;
00930	
00940	ALPHA←800; SAMPLE←0; GAMMA←40; PERIOD←170;
00950	SAMPLE←0;
00960	
01030	ARRYIN(CHAN3,BUF1[0],512);
01040	⊃ OUTSTR("Initial load of BUF1 "&CRLF);
01050	OLDBUF←0; VSTART←0; POINTR←VEND←POINT(12,BUF1[0],-1); I←0;
01060	SPX←0; DEFINES; INFLAG←0; PREPARE;  INFLAG←1;
01070	
01080	WHILE EOF=0 DO BEGIN "TRACK"
01090	
01100	⊂ Find a possible vowel region;
01110	WHILE EOF=0 DO BEGIN "SKIP"
01120	  K←ILDB(POINTR); IF K≥2047 THEN K←4096-K; ⊂ Make positive here;
01130	  I←I+1; IF (I≥1536)∧(EOF=0) THEN REPLACE;
01140	  IF I≥1536 THEN DONE "TRACK";
01150	  IF K≥ALPHA THEN DONE "SKIP";
01160	  END "SKIP";
01170	 OUTSTR(CRLF&"Vowel number "&cvs(SPX)&" at "&CVS(SAMPLE+I)&CRLF);
01180	
01190	⊂ Ignore the first pitch period;
01200	FOR J←0 STEP 1 UNTIL 200 DO BEGIN
01210	  IBP(POINTR);
01220	  I←I+1; IF (I≥1536)∧(EOF=0) THEN REPLACE;
01230	  IF I≥1536 THEN DONE "TRACK"; 
01240	  END;
01250	
01260	ISAVE←SAMPLE+I;
01270	HOLD[0]←K; IF K>0 THEN STATE←0 ELSE STATE←1;
01275	MAX←MIN←MAXOLD←MINOLD←XING←0; 
01290	
01300	
01310	FOR K←0 STEP 1 UNTIL 2 DO PEAK[K]←NPEAK[K]←0;
01320	ZEROS←0;
01330	FOR J←1 STEP 1 UNTIL 511 DO BEGIN "SAVE"
01340	  K←ILDB(POINTR); IF K>2047 THEN K←K-4096;
01350	  HOLD[J]←K;
01360	  I←I+1; IF (I≥1536)∧(EOF=0) THEN REPLACE;
01370	  IF I≥1536 THEN DONE "TRACK"; 
01380	
01390	  IF STATE=0 THEN BEGIN
01400	    IF K>MAX THEN BEGIN  MAXX←J; MAX←K; END;
01410	    IF K<0 THEN BEGIN
01420	      IF (MAX>MAXOLD)∨(MAXX>OLDXX+PERIOD%2) THEN BEGIN
01425	        MAXOLD←MAX; OLDXX←MAXX;
01430	        FOR L←0 STEP 1 UNTIL 2 DO IF MAX<PEAK[L] THEN DONE;
01440	        IF L>0 THEN FOR L←L-1 STEP -1 UNTIL 0 DO BEGIN
01450	          MAX↔PEAK[L]; MAXX↔PLACE[L]; XING↔PEAKX[L]; END;
01470	        END;
01480	      MAX←0; STATE←1; XING←J; END;
01485	
01490	    END ELSE BEGIN
01495	
01500	    IF K<MIN THEN BEGIN  MINX←J; MIN←K; END;
01520	    IF K>0 THEN BEGIN
01530	      IF (MIN<MINOLD)∨(MINX>OLDNX+PERIOD%2) THEN BEGIN
01535	        MINOLD←MIN; OLDNX←MINX;
01540	        FOR L←0 STEP 1 UNTIL 2 DO IF MIN>NPEAK[L] THEN DONE;
01550	        IF L>0 THEN FOR L←L-1 STEP -1 UNTIL 0 DO BEGIN
01560	          MIN↔NPEAK[L]; MINX↔NPLACE[L]; XING↔NPEAKX[L]; END;
01580	        END;
01590	      ZEROS←ZEROS+1;
01600	      MIN←0; STATE←0; XING←J; END;
01610	    END;
01620	⊂ OUTSTR(CVS(K)&TB);
01630	  END "SAVE";
01640	
01650	 FOR J←0 STEP 1 UNTIL 2 DO
01660	  OUTSTR(CVS(PEAKX[J])&TB&CVS(PLACE[J])&TB&CVS(PEAK[J])&TB
01670	   &TB&CVS(NPEAKX[J])&TB&CVS(NPLACE[J])&TB&CVS(NPEAK[J])&CRLF);
01680	
01690	K←0;
01700	FOR J←0 STEP 1 UNTIL 2 DO K←K+PEAK[J]-NPEAK[J];
01710	OUTSTR("SIGMA="&CVS(K)&TB&"ZEROS="&CVS(ZEROS)&CRLF);
01720	IF K<ALPHA*4 THEN BEGIN
01730	  OUTSTR("Woops, not a vowel"&crlf);
01740	  CONTINUE "TRACK"; END;
01750	
01760	IF ZEROS>GAMMA THEN BEGIN
01770	  OUTSTR("Woops, too many zeros"&CRLF);
01780	  CONTINUE "TRACK"; END;
01790	
01800	⊂ Find positive side;
01810	K←0;
01820	FOR J←0 STEP 1 UNTIL 2 DO K←K+PEAK[J]+NPEAK[J];
01830	⊃ IF K<0 THEN OUTSTR("Upside down"&CRLF);
01840	IF K<0 THEN FOR K←0 STEP 1 UNTIL 2 DO BEGIN
01845	  PEAKX[K]↔NPEAKX[K];
01850	  PLACE[K]↔NPLACE[K]; PEAK[K]↔NPEAK[K]; END;
01860	
01870	FOR K←0 STEP 1 UNTIL 1 DO
01880	  FOR L←K+1 STEP 1 UNTIL 2 DO
01890	    IF PLACE[K]>PLACE[L] THEN BEGIN
01895	      PEAKX[K]↔PEAKX[L];
01900	      PLACE[K]↔PLACE[L]; PEAK[K]↔PEAK[L]; END;
01910	
01920	IF (J←PLACE[2]-PLACE[0])<PERIOD THEN BEGIN
01930	  OUTSTR("Too little spread"&CRLF); CONTINUE "TRACK"; END;
01940	
01950	IF (PLACE[2]-PLACE[0]<PERIOD*5%4)∧(PEAK[1]<(PEAK[0]+PEAK[2])%2) THEN BEGIN
01960	PSTART←PLACE[0]; PEND←PLACE[2]; END ELSE
01970	IF PLACE[1]-PLACE[0]<PLACE[2]-PLACE[1] THEN BEGIN
01980	  PSTART←PLACE[1]; PEND←PLACE[2]; END ELSE BEGIN
01990	  PSTART←PLACE[0]; PEND←PLACE[1]; END;
02000	
02010	 OUTSTR("Pstart="&cvs(PSTART)&"  Pend="&CVS(PEND)&"  M="&CVS(PEND-PSTART)&CRLF);
02020	PERIOD←(PERIOD+PEND-PSTART)%2;
02030	
02040	FORM(1);
02050	PREPARE;
02060	⊃ FOR J←0 STEP 1 UNTIL 9 DO OUTSTR(CVS(INDATA[J])&TB);
02070	
02080	J←0; SPOOR[0,SPX]←ISAVE+PSTART;
02090	OUTSTR("ISAVE="&CVS(ISAVE)&TB&"PSTART="&CVS(PSTART)&TB&"SPOOR[0,SPX]="&CVS(SPOOR[0,SPX])&CRLF);
02100	
02110	FOR K←1 STEP 1 UNTIL 3 DO BEGIN
02120	  SPOOR[K,SPX]←INDATA[J]*2500%256; J←J+1; END;
02130	
02140	  J←6;
02150	FOR K←4 STEP 1 UNTIL 6 DO BEGIN
02160	  SPOOR[K,SPX]←INDATA[J]; J←J+1; END;
02170	
02180	SPX←SPX+1; IF SPX≥20 THEN SPX←20;
02190	⊂ Go to end of this vowel;
02200	M←PEND-PSTART; L←0;
02210	FOR J←PEND STEP 1 UNTIL 511 DO BEGIN
02220	  IF (HOLD[J]<ALPHA)∧(HOLD[J]>-ALPHA) THEN L←L+1 ELSE L←0;
02230	  IF L>PERIOD*5%4 THEN DONE;	⊂ At the end of the vowel;
02240	  END;
02250	
02260	IF J≥512 THEN BEGIN	⊂ Not at the end of the vowel;
02270	  WHILE EOF=0 DO BEGIN
02280	    K←ILDB(POINTR); IF K≥2047 THEN K←4096-K; ⊂ Make positive here;
02290	    I←I+1; IF (I≥1536)∧(EOF=0) THEN REPLACE;
02300	  IF I≥1536 THEN DONE "TRACK"; 
02310	    IF K<ALPHA THEN L←L+1 ELSE L←0;
02320	    IF L>PERIOD*5%4 THEN DONE;
02330	    END;
02340	  END;
02350	
02360	END "TRACK";
02370	END;
02380	END;